home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / extras0.em < prev    next >
Lisp/Scheme  |  1993-07-15  |  13KB  |  490 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: extras0.em
  4. ;; Date: Fri Jan 10 04:17:12 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule extras0
  11.   (
  12.    init
  13.    (except (car cdr cadr cddr) init)
  14.    macros0
  15.    characters
  16.    ) 
  17.   ()
  18.  
  19.   (defun not (widget) (null widget))
  20.   
  21.   (export not)
  22.  
  23.   (defun caar (x) (car (car x)))
  24.   (defun cadr (x) (car (cdr x)))
  25.   (defun cdar (x) (cdr (car x)))
  26.   (defun cddr (x) (cdr (cdr x)))
  27.  
  28.   (export caar cadr cdar cddr)
  29.  
  30.   (defun caaar (x) (car (car (car x))))
  31.   (defun caadr (x) (car (car (cdr x))))
  32.   (defun cadar (x) (car (cdr (car x))))
  33.   (defun caddr (x) (car (cdr (cdr x))))
  34.   (defun cdaar (x) (cdr (car (car x))))
  35.   (defun cdadr (x) (cdr (car (cdr x))))
  36.   (defun cddar (x) (cdr (cdr (car x))))
  37.   (defun cdddr (x) (cdr (cdr (cdr x))))
  38.  
  39.   (export caaar caadr cadar caddr cdaar cdadr cddar cdddr)
  40.  
  41.   (defun caaaar (x) (car (car (car (car x)))) )
  42.   (defun caaadr (x) (car (car (car (cdr x)))) )
  43.   (defun caadar (x) (car (car (cdr (car x)))) )
  44.   (defun caaddr (x) (car (car (cdr (cdr x)))) )
  45.   (defun cadaar (x) (car (cdr (car (car x)))) )
  46.   (defun cadadr (x) (car (cdr (car (cdr x)))) )
  47.   (defun caddar (x) (car (cdr (cdr (car x)))) )
  48.   (defun cadddr (x) (car (cdr (cdr (cdr x)))) )
  49.   (defun cdaaar (x) (cdr (car (car (car x)))) )
  50.   (defun cdaadr (x) (cdr (car (car (cdr x)))) )
  51.   (defun cdadar (x) (cdr (car (cdr (car x)))) )
  52.   (defun cdaddr (x) (cdr (car (cdr (cdr x)))) )
  53.   (defun cddaar (x) (cdr (cdr (car (car x)))) )
  54.   (defun cddadr (x) (cdr (cdr (car (cdr x)))) )
  55.   (defun cdddar (x) (cdr (cdr (cdr (car x)))) )
  56.   (defun cddddr (x) (cdr (cdr (cdr (cdr x)))) )
  57.  
  58.   (export caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 
  59.       cdaaar cdaadr cdadar cdaddr cddaar cdddar cddadr cddddr)
  60.  
  61.   (defun eqcar (a b) (cond ((atom a) nil) ((eq (car a) b) t) (t nil)))
  62.  
  63.   (export eqcar)
  64.  
  65.   (defun mkquote (x) (list 'quote x))
  66.  
  67.   (export mkquote)
  68.  
  69.   (defun assq (a l)
  70.     (cond
  71.      ((null l) nil)
  72.      ((eq a (caar l)) (car l))
  73.      (t (assq a (cdr l)))) )
  74.  
  75.   (export assq)
  76.  
  77.   (defun list-ref (l n)
  78.     (if (equal n 0) (car l)
  79.       (list-ref (cdr l) (\- n 1))))
  80.  
  81.   (export list-ref)
  82.  
  83.   (defun \@list-ref-update\@ (l n obj)
  84.     (if (equal n 0) ((setter car) l obj)
  85.       (\@list-ref-update\@ (cdr l) (- n 1) obj)))
  86.  
  87.   (interpret-time 
  88.    (defun reverse-list (l)
  89.      (reverse-aux l nil))
  90.    
  91.    (defun reverse-aux (l so-far)
  92.      (if l (reverse-aux (cdr l)
  93.             (cons (car l) so-far))
  94.        so-far))
  95.    )
  96.  
  97.   (compile-time 
  98.    (defun reverse-list (l)
  99.      (labels ((rev1 (l n)
  100.             (if (null l) n
  101.               (rev1 (cdr l) (cons (car l) n)))))
  102.          (rev1 l nil)))
  103.    )
  104.  
  105.   (export reverse-list)
  106.  
  107.   (defun subst (a b c)
  108.     (cond
  109.      ((equal c b) a)
  110.      ((atom c) c)
  111.      (t 
  112.       ((lambda (carc cdrc)
  113.      (cond ((and (eq carc (car c)) (eq cdrc (cdr c))) c)
  114.            (t (cons carc cdrc))))
  115.        (subst a b (car c))
  116.        (subst a b (cdr c))))))
  117.  
  118.   (export subst)
  119.  
  120.   (defun delete (a b comp)
  121.     (cond
  122.      ((null b) nil)
  123.      ((comp a (car b)) (cdr b))
  124.      (t ((lambda (del)
  125.        (cond ((eq del (cdr b)) b)
  126.          (t (cons (car b) del))))
  127.      (delete a (cdr b) comp)))))
  128.  
  129.   (export delete)
  130.  
  131.   (defun deleteq (a b)
  132.     (cond
  133.      ((null b) nil)
  134.      ((eq a (car b)) (cdr b))
  135.      (t ((lambda (del)
  136.        (cond ((eq del (cdr b)) b)
  137.          (t (cons (car b) del))))
  138.      (deleteq a (cdr b))))))
  139.  
  140.   (export deleteq)
  141.  
  142.   ;;
  143.   ;; Missing bits...
  144.   ;;
  145.  
  146.   (defun list-copy-aux (l new)
  147.     (if l (list-copy-aux (cdr l) (nconc new (cons (car l) nil)))
  148.       new))
  149.  
  150.   (defun list-copy (l) (list-copy-aux l nil))
  151.  
  152.   (export list-copy)
  153.  
  154.   ;; Conversion
  155.   ;; According to the standard (nearly)
  156.  
  157.   (defconstant *convert-tab* (make-table eq))
  158.  
  159.   (defun converter (cl)
  160.     (let ((xx (sys-table-ref *convert-tab* cl)))
  161.       (if (not (null xx))
  162.       xx
  163.     (let ((new-gen (make-converter-generic cl)))
  164.       ((setter converter) cl new-gen)
  165.       new-gen))))
  166.       
  167.  
  168.   (defun make-converter-generic (cl)
  169.     (let ((gf (make <generic-function>
  170.             'name (make-symbol (string-append (symbol-unbraced-name (class-name cl)) "-converter"))
  171.             'lambda-list '(a)
  172.             'method-class <method>)))
  173.       (add-method gf (make <method>
  174.                'signature (list cl)
  175.                'function (method-lambda (o) o)))))
  176.  
  177.   
  178.   
  179.   
  180.   ((setter setter) converter
  181.    (lambda (cl fn)
  182.      ((setter sys-table-ref) *convert-tab* cl fn)))
  183.   
  184.   
  185.   (defun convert (x cl)
  186.     "(convert obj class)
  187.      Converts obj to be an equivalent object of the specified class.
  188.      Calls (converter class) in order to achieve this"
  189.     ((converter cl) x))
  190.   
  191.   (export converter convert)
  192.   ;; shove in the defined methods...
  193.   ;; Really so trivial that we could use lisp functions...
  194.  
  195.   (add-method (converter <vector>)
  196.           (make <method>
  197.             'signature (list <pair>)
  198.             'function generic_generic_convert\,Cons\,Vector))
  199.  
  200.   (add-method (converter <pair>)
  201.           (make <method>
  202.             'signature (list <vector>)
  203.             'function generic_generic_convert\,Vector\,Cons))
  204.  
  205.   (add-method (converter <vector>)
  206.           (make <method>
  207.             'signature (list (class-of nil))
  208.             'function 
  209.             (method-lambda (c)
  210.                    (make-vector 0))))
  211.  
  212.   (add-method (converter <string>)
  213.           (make <method> 
  214.             'signature (list <object>)
  215.             'function (method-lambda (obj)
  216.                          (format nil "~a" obj))))
  217.   (add-method (converter <string>)
  218.           (make <method>
  219.             'signature (list <character>)
  220.             'function (method-lambda (obj)
  221.                          (make-string 1 obj))))
  222.  
  223.   (add-method (converter <integer>)
  224.           (make <method>
  225.             'signature (list <character>)
  226.             'function character-to-integer))
  227.  
  228.  
  229.   ;; Also need to add:
  230.   ;; (allsorts) number from string
  231.   ;; char<--int
  232.   ;; string->pair
  233.  
  234.  
  235.   ;; Changing the habit of a lifetime
  236.  
  237.   (defconstant length (make <generic-function>
  238.                 'name 'length
  239.                 'lambda-list '(l)
  240.                 'method-class <method>))
  241.  
  242.   (add-method length (make <method>
  243.                'signature (list <pair>)
  244.                'function list-length))
  245.  
  246.   (add-method length (make <method>
  247.                'signature (list (class-of nil))
  248.                'function (method-lambda (x) 0)))
  249.  
  250.   (add-method length (make <method>
  251.                'signature (list <vector>)
  252.                'function vector-length))
  253.  
  254.   (add-method length (make <method>
  255.                'signature (list <string>)
  256.                'function string-length))
  257.  
  258.   (export length)
  259.   
  260.                     ; more comparison methods...
  261.  
  262.   (add-method equal
  263.           (make <method>
  264.             'signature (list <object> <object>)
  265.             'function generic_equal\,Object\,Object))
  266.   (add-method equal
  267.           (make <method>
  268.             'signature (list <pair> <pair>)
  269.             'function generic_equal\,Cons\,Cons))
  270.   (add-method equal
  271.           (make <method>
  272.             'signature (list <vector> <vector>)
  273.             'function generic_equal\,Vector\,Vector))
  274.  
  275.   (add-method equal
  276.           (make <method>
  277.             'signature (list <structure> <structure>)
  278.             'function generic_equal\,Basic_Structure\,Basic_Structure))
  279.   (add-method equal
  280.           (make <method>
  281.             'signature (list <class> <class>)
  282.             'function generic_equal\,Standard_Class\,Standard_Class))
  283.  
  284.   ;; Eql.
  285.   ;; Eq. except on numbers
  286.   (defconstant eql (make <generic-function>
  287.                 'name 'eql
  288.                 'lambda-list '(x y)
  289.                 'method-class <method>))
  290.  
  291.   
  292.   (add-method eql
  293.           (make <method>
  294.             'signature (list <object> <object>)
  295.             'function eq))
  296.  
  297.   (add-method eql
  298.           (make <method>
  299.             'signature (list <number> <number>)
  300.             'function (method-lambda (x y) (= x y))))
  301.  
  302.  
  303.   (export eql)
  304.   ;; More copiers
  305.   
  306.   (add-method copy 
  307.           (make <method>
  308.             'signature (list <string>)
  309.             'function string-copy))
  310.  
  311.   ;; standard streams
  312.   (defun make-std-stream (n)
  313.     (let ((fn (lambda () (vector-ref (std-streams) n)))
  314.       (fn-setter (lambda (s) (let ((old (vector-ref (std-streams) n)))
  315.                    ((setter vector-ref) (std-streams) n s) 
  316.                    old))))
  317.       ((setter setter) fn fn-setter)
  318.       fn))
  319.  
  320.   (defconstant standard-input-stream (make-std-stream 0))
  321.   (defconstant standard-output-stream (make-std-stream 1))
  322.   (defconstant standard-error-stream (make-std-stream 2))
  323.  
  324.   (export standard-input-stream standard-output-stream standard-error-stream)
  325.  
  326.   ;; Format 
  327.  
  328.   (defun formatter (c)
  329.     (vector-ref (std-formatters)
  330.         (convert c <integer>)))
  331.  
  332.   ((setter setter) formatter
  333.    (lambda (c val)
  334.      ((setter vector-ref) (std-formatters)
  335.       (convert c <integer>) val)))
  336.  
  337.   (deflocal *sscl* nil)
  338.   (defun format-string-stream-class () *sscl*)
  339.  
  340.   ((setter setter) format-string-stream-class 
  341.    (lambda (x) (setq *sscl* x)))
  342.   
  343.   (defun format (s msg . args)
  344.     (cond ((null s) 
  345.        (let ((strm (make (format-string-stream-class))))
  346.          (internal-format strm msg args)
  347.          (convert strm <string>)))
  348.       ((eq s t)
  349.        (internal-format (standard-output-stream) msg args))
  350.       (t (internal-format s msg args))))
  351.   
  352.   
  353.   (export format formatter format-string-stream-class)
  354.  
  355.   ;; more reflective methods
  356.  
  357.   (defun mapcan (f l)
  358.     (if (atom l) nil
  359.       (nconc (f (car l))
  360.          (mapcan f (cdr l)))))
  361.  
  362.   (defconstant generic-function-methods
  363.     (make <generic-function>
  364.       'name 'generic-function-methods
  365.       'lambda-list '(gf)
  366.       'method-class <method>))
  367.  
  368.   (export generic-function-methods)
  369.  
  370.   (defconstant gfm 
  371.     (method-lambda (gf)
  372.            (labels ((get-method (l)
  373.                     (if (atom (cadr l))
  374.                         (list (cadr l))
  375.                       (mapcan get-method (cdr l)))))
  376.                (mapcan get-method (generic-method-table gf)))))
  377.  
  378.   (add-method generic-function-methods
  379.           (make <method>
  380.             'signature (list <generic-function>)
  381.             'function gfm))
  382.  
  383.   (defconstant find-method
  384.     (make <generic-function>
  385.       'name 'find-method
  386.       'lambda-list '(gf sig)
  387.       'method-class <method>))
  388.  
  389.   (defun match-sigs (sig meths)
  390.     (cond ((atom meths) ())
  391.       ((equal sig (method-signature (car meths))) (car meths))
  392.       (t (match-sigs sig (cdr meths)))))
  393.  
  394.   (add-method find-method
  395.           (make <method>
  396.             'signature (list <generic-function> <object>)
  397.             'function (method-lambda (gf sig)
  398.                          (match-sigs sig (generic-function-methods gf)))))
  399.  
  400.   (export find-method)
  401.  
  402.   ;; next version junk....
  403.  
  404.   (defun make-constructor (cl)
  405.     (lambda a
  406.       (initialize (allocate cl a) a)))
  407.  
  408.   (export make-constructor)
  409.  
  410.   ;; add make-predicate...
  411.  
  412.   (defconstant make-predicate
  413.     (make <generic-function>
  414.       'name 'make-predicate
  415.       'lambda-list '(cl)
  416.       'method-class <method>))
  417.  
  418.  
  419.   ;; probably portable
  420.   (add-method make-predicate 
  421.           (make 
  422.            <method>
  423.            'signature (list <class>)
  424.            'function 
  425.            (method-lambda (x)
  426.                   (let ((gf (make <generic-function>
  427.                           'name (make-symbol (string-append (symbol-unbraced-name (class-name x)) 
  428.                                         "-p"))
  429.                           'lambda-list '(obj)
  430.                           'method-class <method>)))
  431.                 (add-method gf 
  432.                         (make <method>
  433.                           'signature (list <object>)
  434.                           'function (method-lambda (ob)
  435.                                        nil)))
  436.                 (add-method gf 
  437.                         (make <method>
  438.                           'signature (list x)
  439.                           'function (method-lambda (ob)
  440.                                        t)))
  441.                 gf))))
  442.   (export make-predicate)
  443.  
  444.   (defun map-table (fn tab)
  445.     (let ((vector (table-values tab)))
  446.       (labels ((map (n)
  447.             (if (< n 0) nil
  448.               (let ((aa (vector-ref vector n)))
  449.             (if (atom aa) nil
  450.               (fn (car aa) (cdr aa)))
  451.             (map (- n 1))))))
  452.           (map (- (vector-length vector) 1)))))
  453.  
  454.   (defun table-keys (tab)
  455.     (let ((lst nil))
  456.       (map-table (lambda (a b) (setq lst (cons a lst))) tab)
  457.       lst))
  458.  
  459.   (export map-table table-keys)
  460.  
  461.   ;; Character stuff
  462.   (defconstant char-hash-vector
  463.     #(1 87 49 12 176 178 102 166 121 193 6 84 249 230 44 163
  464.     14 197 213 181 161 85 218 80 64 239 24 226 236 142 38 200
  465.     110 177 104 103 141 253 255 50 77 101 81 18 45 96 31 222
  466.     25 107 190 70 86 237 240  34 72 242 20 214 244 227 149 235
  467.     97 234 57 22 60 250 82 175 208 5 127 199 111 62 135 248
  468.     174 169 211 58 66 154 106 195 245 171 17 187 182 179 0 243
  469.     132 56 148 75 128 133 158 100 130 126 91 13 153 246 216 219
  470.     119 68 223 78 83 88 201 99 122 11 92 32 136 114 52 10
  471.     138 30 48 183 156 35 61 26 143 74 251 94 129 162 63 152
  472.     170 7 115 167 241 206 3 150 55 59 151 220 90 53 23 131
  473.     125 173 15 238 79 95 89 16 105 137 225 224 217 160 37 123
  474.     118 73 2 157 46 116 9 145 134 228 207 212 202 215 69 229
  475.     27 188 67 124 168 252 42 4 29 108 21 247 19 205 39 203
  476.     233 40 186 147 198 192 155 33 164 191 98 204 165 180 117 76
  477.     140 36 210 172 41 54 159 8 185 232 113 196 231 47 146 120
  478.     51 65 28 144 254 221 93 189 194 139 112 43 71 109 184 209
  479.     1))
  480.     
  481.   (add-method generic-hash
  482.           (make <method>
  483.             'signature (list <character>)
  484.             'function 
  485.             (method-lambda (x)
  486.                    (vector-ref char-hash-vector (convert x <integer>)))))
  487.  
  488.  
  489.   )
  490.